C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C       Z F C A P U   -   Canonicalise a program-unit
C
C       This routine:
C           a) sets the extended data for each statement-level node to
C              the statement number (for comment indexing),
C           b) converts arithmetic IFs to logical IFs (possibly + GOTO)
C              whenever possible (i.e. if the three labels are not all
C              different),
C           c) adds COMMENT statements before control-flow statements
C              which disappear under flowgraphing (i.e. CONTINUE,
C              unconditional GOTO, ENDIF and ELSE),
C           d) makes all DO loops end on unique CONTINUE statements.
C
 
        SUBROUTINE ZFCAPU(PUROOT)
        INTEGER PUROOT
 
        INTEGER MDNEST
        PARAMETER (MDNEST=199)
 
        INTEGER STPTR,PTR,NODTYP,DOSP,DOLBL(MDNEST),NEWLBL(MDNEST),
     +          LABEL,STMTNO,DPTR,PTR1,PTR2
 
        SAVE STMTNO
 
        INTEGER ZYGENL,ZYROOT,ZYCRND,ZYCMEX
        EXTERNAL ZYGENL,ZYROOT,ERROR,ZYCHDN,ZYSATT,ZYADNX,ZYADSN,ZYCRND,
     +           ZYSTXF,ZYCMEX
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C Common block and access functions for YP parse tree
C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C Use "JABC12" to try to avoid conflicts with ordinary variables
        INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
 
        NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
        PREV(JABC12)=(TREE(3,JABC12)/46340)
        UP(JABC12)=(TREE(1,JABC12)/46340)
        DOWN(JABC12)=TREE(2,JABC12)
        NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
        NATTR(JABC12)=TREE(4,JABC12)
 
        IF (DOWN(ZYROOT()).EQ.PUROOT) STMTNO=1
        STPTR=DOWN(PUROOT)
        DOSP=0
        LABEL=37000
 
 200    CALL ZYSTXF(STPTR,STMTNO)
        NODTYP=NTYPE(STPTR)
        IF (NODTYP.EQ.51 .OR. NODTYP.EQ.60 .OR.
     +      NODTYP.EQ.59 .OR. NODTYP.EQ.62 .OR.
     +      NODTYP.EQ.83) THEN
            IF (ZYCMEX(STMTNO).EQ.-2) THEN
C
C Turn control-flow statements (which will disappear) which have
C comments associated with them into Comment statements plus the
C control-flow statement.
C
                IF (NODTYP.EQ.51 .OR. NODTYP.EQ.60 .OR.
     +              NODTYP.EQ.83 .AND. DOWN(STPTR).EQ.0) THEN
C GOTO/ENDIF comments will follow the preceding statement
C (RETURN without expression is treated as a GOTO)
                    PTR=ZYCRND(131,0)
                    CALL ZYSTXF(STPTR,0)
                    CALL ZYSTXF(PTR,STMTNO)
                    CALL ZYADNX(PTR,STPTR)
                    CALL ZYADNX(STPTR,PTR)
                ELSE
C (NODTYP.EQ.N_ELSE .OR. NODTYP.EQ.N_CONTINUE)
C ELSE/CONTINUE comments will precede the following statement
                    CALL ZYSTXF(STPTR,0)
                    STMTNO=STMTNO-1
                    CALL ZYADNX(ZYCRND(131,0),STPTR)
                END IF
            END IF
        END IF
C
C Canonicalise DO loop begins and ends
C
        IF (NODTYP.EQ.61) THEN
            IF (DOSP.EQ.MDNEST) CALL ERROR('DO loops too deeply nested')
            DOSP=DOSP+1
            PTR=DOWN(STPTR)
            IF (NTYPE(PTR).EQ.115) THEN
                PTR2=NEXT(PTR)
                CALL ZYREPL(PTR,PTR2)
                PTR1=ZYCRND(132,0)
                CALL ZYADNX(PTR1,STPTR)
                CALL ZYADNX(STPTR,PTR1)
                CALL ZYADSN(PTR1,PTR)
                SYMBOL(4,-DOWN(PTR))=PTR1
                PTR=PTR2
            ELSE
                IF (NTYPE(PREV(STPTR)).EQ.62 .OR.
     +              NTYPE(PREV(STPTR)).EQ.131) THEN
                    PTR1=ZYCRND(132,0)
                    CALL ZYADNX(PTR1,STPTR)
                    CALL ZYADNX(STPTR,PTR1)
                ENDIF
            ENDIF
            DOLBL(DOSP)=-DOWN(PTR)
            IF (SYMBOL(5,DOLBL(DOSP)).GT.0 .OR.
     +          SYMBOL(6,DOLBL(DOSP)).GT.1) THEN
                NEWLBL(DOSP)=ZYGENL(LABEL,SYMBOL(3,DOLBL(DOSP)))
                CALL ZYCHDN(PTR,-NEWLBL(DOSP))
                IF (MOD(SYMBOL(6,DOLBL(DOSP)),
     +                  1000).GT.1) THEN
                    CALL ZYSATT(DOLBL(DOSP),6,
     +                          SYMBOL(6,DOLBL(DOSP))-1)
                END IF
            ELSE
                NEWLBL(DOSP)=0
            END IF
        ELSE IF (DOSP.GT.0) THEN
            PTR=DOWN(STPTR)
            IF (PTR.EQ.0) THEN
C Do nothing
            ELSE IF (NTYPE(PTR).EQ.115) THEN
                IF (DOLBL(DOSP).EQ.-DOWN(PTR)) THEN
 300                IF (NEWLBL(DOSP).NE.0) THEN
                        CALL ZYADNX(ZYCRND(62,
     +                                     ZYCRND(115,
     +                                            -NEWLBL(DOSP))),
     +                              STPTR)
                        STPTR=NEXT(STPTR)
                        CALL ZYSATT(NEWLBL(DOSP),4,STPTR)
                        CALL ZYSATT(NEWLBL(DOSP),6,1)
                    ELSE IF (NODTYP.NE.62) THEN
                        CALL ZYADNX(ZYCRND(62,0),STPTR)
                        DPTR=DOWN(STPTR)
                        CALL ZYADSN(NEXT(STPTR),DPTR)
                        STPTR=NEXT(STPTR)
                        CALL ZYSATT(DOLBL(DOSP),4,STPTR)
                    END IF
                    DOSP=DOSP-1
                    IF (DOSP.GT.0) THEN
                        IF (DOLBL(DOSP).EQ.DOLBL(DOSP+1)) GOTO 300
                    END IF
                END IF
            END IF
        END IF
C
C Canonicalise arithmetic IFs, i.e. do away with them if possible
C
        IF (NODTYP.EQ.55) CALL XFFAIF(STPTR)
        STPTR=NEXT(STPTR)
        STMTNO=STMTNO+1
        IF (STPTR.GT.0) GOTO 200
        IF (DOSP.NE.0)
     +      CALL ERROR('Internal Error: DO LOOP NESTING FAILURE')
 
        END
C ----------------------------------------------------------------------
C
C       X F F A I F   -   (Internal) Fixup Arithmetic IF statements
C
 
        SUBROUTINE XFFAIF(STPTR)
        INTEGER STPTR
 
        INTEGER PTR,L1,L2,L3,LN,LGOTO,COND,LOTHER,ZERO(2)
 
        SAVE ZERO
 
        INTEGER ZYDOWN,ZYNEXT,ZYNTYP,ZYCRND,ZYASTR
        EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,ZYCRND,ZYASTR,ZYADSN,ZYCHNT,
     +           ZYDELT,ZYCHDN,ZYADNX
 
        DATA ZERO/48,129/
 
        PTR=ZYDOWN(STPTR)
        IF (ZYNTYP(PTR).EQ.115) PTR=ZYNEXT(PTR)
        PTR=ZYNEXT(PTR)
        L1=-ZYDOWN(PTR)
        PTR=ZYNEXT(PTR)
        L2=-ZYDOWN(PTR)
        PTR=ZYNEXT(PTR)
        L3=-ZYDOWN(PTR)
        LN=ZYDOWN(ZYNEXT(STPTR))
        IF (LN.NE.0) THEN
            IF (ZYNTYP(LN).EQ.115) THEN
                LN=-ZYDOWN(LN)
            ELSE
                LN=0
            END IF
        END IF
        LOTHER=0
        IF (L1.EQ.L2) THEN
            IF (L1.EQ.LN) THEN
                COND=93
                LGOTO=L3
            ELSE
                COND=90
                LGOTO=L1
                IF (L3.NE.LN) LOTHER=L3
            END IF
        ELSE IF (L2.EQ.L3) THEN
            IF (L2.EQ.LN) THEN
                COND=89
                LGOTO=L1
            ELSE
                COND=94
                LGOTO=L2
                IF (L1.NE.LN) LOTHER=L1
            END IF
        ELSE IF (L1.EQ.L3) THEN
            IF (L1.EQ.LN) THEN
                COND=91
                LGOTO=L2
            ELSE
                COND=92
                LGOTO=L1
                IF (L2.NE.LN) LOTHER=L2
            END IF
        ELSE
            RETURN
        END IF
C
C  N_ARITHIF -> EXPR, L1, L2, L3 BECOMES
C  N_LOG_IF  -> (COND -> EXPR, ICONST(0)), N_GOTO -> N_LABELREF(LGOTO)
C
C  I.E. L1 ==> COND,
C       EXPR MOVED TO UNDER L1
C       L2 ==> ICONST 0 AND MOVED TO UNDER L1 AFTER EXPR
C       L3 ==> N_GOTO
C       N_LABELREF CREATED UNDER L3
C
        CALL ZYCHNT(STPTR,56)
        PTR=ZYDOWN(STPTR)
        IF (ZYNTYP(PTR).EQ.115) PTR=ZYNEXT(PTR)
        L1=ZYNEXT(PTR)
        L2=ZYNEXT(L1)
        L3=ZYNEXT(L2)
        CALL ZYDELT(PTR)
        CALL ZYCHNT(L1,COND)
        CALL ZYADSN(L1,PTR)
        CALL ZYCHNT(L2,107)
        CALL ZYCHDN(L2,-ZYASTR(ZERO))
        CALL ZYADNX(L2,PTR)
        CALL ZYCHNT(L3,51)
        CALL ZYADSN(L3,ZYCRND(116,-LGOTO))
        IF (LOTHER.NE.0) THEN
            CALL ZYADNX(ZYCRND(51,ZYCRND(116,-LOTHER)),STPTR)
            STPTR=ZYNEXT(STPTR)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       Z F G R A F   -   Create flow graph of a program unit
C
 
        LOGICAL FUNCTION ZFGRAF(PUROOT,FG,MFGNOD,FGSIZE,CASETB,MAXCAS,
     +                          NCASES,STARTN,IODWRN)
        INTEGER MFGNOD,NCASES,PUROOT,FGSIZE,MAXCAS,STARTN,IODWRN
        INTEGER FG(8,MFGNOD),CASETB(MAXCAS)
 
        LOGICAL ZFFLOW,ZFSHED
 
C
C Basic flow analysis
C
        ZFGRAF=ZFFLOW(FG,MFGNOD,FGSIZE,CASETB,MAXCAS,NCASES,PUROOT,
     +                STARTN,IODWRN)
        IF (ZFGRAF) THEN
C
C Construct virtual spanning tree and number the nodes accordingly
            CALL ZFSPAN(FG,FGSIZE,STARTN,CASETB,MAXCAS)
C
C Nodes numbered properly, so we can now identify loop beginnings
C and add repeat nodes.
C
            CALL ZFLOOP(FG,MFGNOD,STARTN,FGSIZE,CASETB,MAXCAS,NCASES,
     +                  IODWRN)
C
C Repeat nodes inserted, can now calculate HEAD()
C (false return is for irreducible flowgraphs - no further processing)
C
            ZFGRAF=ZFSHED(FG,FGSIZE,STARTN,CASETB,MAXCAS,IODWRN)
            IF (ZFGRAF) THEN
C
C Add forward inarc counts
C
                CALL ZFICNT(FG,FGSIZE,CASETB,MAXCAS)
C
C Calculate DOM()
C
                CALL ZFSDOM(FG,FGSIZE,CASETB,MAXCAS,STARTN)
C
C Calculate FOLLOW sets: each node is in at most 1 follow set.
C
                CALL ZFFOLL(FG,FGSIZE,CASETB,MAXCAS)
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       Z F F L O W   -   Do basic flow analysis
C
 
        LOGICAL FUNCTION ZFFLOW(FG,MFGNOD,FGSIZE,CASETB,MAXCAS,NCASES,
     +                          PUPTR,STARTN,IODWRN)
        INTEGER MFGNOD,FGSIZE,MAXCAS,NCASES,PUPTR,STARTN,IODWRN
        INTEGER FG(8,MFGNOD),CASETB(MAXCAS)
 
        INTEGER NONEXE,SLC,EXIT,BRANCH,CASE,JUMP,JOIN,IO
        PARAMETER (NONEXE=0,SLC=1,EXIT=2,BRANCH=3,CASE=4,JUMP=5,JOIN=6,
     +             IO=7)
 
        INTEGER MDNEST,MAXJMP
        PARAMETER (MDNEST=100,MAXJMP=500)
 
        INTEGER DOLVL,DOSTMT(MDNEST),ENDDO(MDNEST),NEXTST,NXT,FSTEXE,
     +          JTABLE(2,MAXJMP),NESTLV,STPTR,FGNTYP,NJUMPS,PTR,
     +          STTYPE(132)
 
        SAVE STTYPE
 
        LOGICAL XFLCAS
 
        INTEGER ZYJMPA
        EXTERNAL ZYJMPA,ERROR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C Common block and access functions for YP parse tree
C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C Use "JABC12" to try to avoid conflicts with ordinary variables
        INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
 
        NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
        PREV(JABC12)=(TREE(3,JABC12)/46340)
        UP(JABC12)=(TREE(1,JABC12)/46340)
        DOWN(JABC12)=TREE(2,JABC12)
        NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
        NATTR(JABC12)=TREE(4,JABC12)
 
        DATA STTYPE(6)/EXIT/
        DATA STTYPE(7),STTYPE(8),STTYPE(16),
     +       STTYPE(20),STTYPE(24),STTYPE(26),
     +       STTYPE(30),STTYPE(35),STTYPE(37),
     +       STTYPE(38),STTYPE(39),STTYPE(41),
     +       STTYPE(78),STTYPE(121)
     +       /14*NONEXE/
        DATA STTYPE(18),STTYPE(49),STTYPE(131),
     +       STTYPE(63),STTYPE(64),STTYPE(67),
     +       STTYPE(82),STTYPE(50),STTYPE(132)
     +       /9*SLC/
        DATA STTYPE(65),STTYPE(66),STTYPE(72),
     +       STTYPE(73),STTYPE(74),STTYPE(75),
     +       STTYPE(76),STTYPE(77)
     +       /8*IO/
        DATA STTYPE(51),STTYPE(83)
     +       /2*JUMP/
        DATA STTYPE(52),STTYPE(53),STTYPE(55)
     +       /3*CASE/
        DATA STTYPE(56),STTYPE(57),STTYPE(58),
     +       STTYPE(61)
     +       /4*BRANCH/
        DATA STTYPE(59),STTYPE(60),STTYPE(62)
     +       /3*JOIN/
 
        DOLVL=0
        NJUMPS=0
        FGSIZE=0
        STARTN=1
        NCASES=0
        STPTR=DOWN(PUPTR)
        FSTEXE=0
        ZFFLOW=.FALSE.
 
  50    IF (NTYPE(STPTR).EQ.18) THEN
            IF (NCASES.EQ.0 .AND. FSTEXE.NE.0) THEN
                NCASES=1
                CASETB(1)=FSTEXE
            END IF
            NCASES=NCASES+1
            CASETB(NCASES)=STPTR
        ELSE IF (FSTEXE.EQ.0 .AND. STTYPE(NTYPE(STPTR)).NE.NONEXE) THEN
            FSTEXE=STPTR
        END IF
        STPTR=NEXT(STPTR)
        IF (STPTR.NE.0) GOTO 50
        IF (NCASES.GT.0) CALL XFNODE(FG,MFGNOD,FGSIZE,-2,-NCASES,-1)
        STPTR=DOWN(PUPTR)
 
 100    FGNTYP=STTYPE(NTYPE(STPTR))
        IF (FGNTYP.EQ.EXIT) THEN
            NEXTST=0
            NXT=0
        ELSE
C
C Find out which statement is supposed to be next in the normal
C sequential execution scheme.
C
            NEXTST=STPTR
 200        NEXTST=NEXT(NEXTST)
            IF (STTYPE(NTYPE(NEXTST)).EQ.NONEXE) GOTO 200
            NXT=NEXTST
C
C If the next executable statement is an ELSE or ELSEIF, control instead
C passes to the next ENDIF at this nesting level of block-ifs.
C (this is the only difference between ELSE and CONTINUE, ...)
C
            IF (NTYPE(NXT).EQ.59 .OR. NTYPE(NXT).EQ.58)
     +      THEN
                NESTLV=0
 300            NXT=NEXT(NXT)
                IF (NTYPE(NXT).EQ.57) THEN
                    NESTLV=NESTLV+1
                    GOTO 300
                ELSE IF (NTYPE(NXT).NE.60) THEN
                    GOTO 300
                ELSE
                    NESTLV=NESTLV-1
                    IF (NESTLV.GE.0) GOTO 300
                END IF
C
C Also, control passes from the last statement of the DO body to the top
C of the loop (where it is tested); the terminal statement (always a
C continue) simply becomes a jump to the following code (loop exit).
            ELSE IF (DOLVL.GT.0) THEN
                IF (NXT.EQ.ENDDO(DOLVL)) NXT=DOSTMT(DOLVL)
            END IF
        END IF
C
C Here we actually process the current statement
C
 400    IF (FGNTYP.EQ.IO) THEN
            CALL XFIXIO(STPTR,FGNTYP)
        ELSE IF (NTYPE(STPTR).EQ.82) THEN
C Check out a subroutine call for alternate return addresses (CASE)
            CALL XFCHCL(STPTR,FGNTYP)
        END IF
C Having straightened that out, we proceed...
        IF (FGNTYP.EQ.SLC) THEN
C Straight-Line-Code
            IF (NTYPE(STPTR).EQ.63) THEN
                PTR=PREV(DOWN(UP(NXT)))
                CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,PTR,0)
            ELSE
                CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,NXT,0)
            END IF
        ELSE IF (FGNTYP.EQ.BRANCH) THEN
C LOG-IF, IF-THEN, ELSE-IF, DO
            IF (NTYPE(STPTR).EQ.56) THEN
                PTR=DOWN(STPTR)
                IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
                CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,NEXT(PTR),NXT)
                STPTR=NEXT(PTR)
                FGNTYP=STTYPE(NTYPE(STPTR))
C After doing logical IF, must do its dependent statement
                GOTO 400
            ELSE IF (NTYPE(STPTR).NE.61) THEN
C Some sort of IF block (IF-THEN or ELSE-IF).
C The "true" outarc is simply the next statement (already set up for us
C in NXT), so now we find the "false" outarc; this is the next ELSE-IF,
C ELSE, or END-IF at this nesting level of IF blocks.
                NESTLV=0
                PTR=STPTR
 500            PTR=NEXT(PTR)
                IF (NTYPE(PTR).EQ.57) THEN
                    NESTLV=NESTLV+1
                    GOTO 500
                ELSE IF (NESTLV.GT.0) THEN
                    IF (NTYPE(PTR).EQ.60) NESTLV=NESTLV-1
                    GOTO 500
                ELSE IF (NTYPE(PTR).NE.58 .AND.
     +                   NTYPE(PTR).NE.59 .AND.
     +                   NTYPE(PTR).NE.60) THEN
                    GOTO 500
                END IF
                CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,NXT,PTR)
            ELSE
C We have a "DO" statement: the "true" outarc leads to the DO body
C (already set up for us in NXT) so we must find the "false" outarc;
C this is easy, since we have an ordinary label_ref for it.
                PTR=DOWN(STPTR)
                IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
                IF (ZYJMPA(PTR).EQ.0) THEN
                    CALL XFULER(STPTR,-DOWN(PTR),IODWRN)
                    RETURN
                END IF
                PTR=ZYJMPA(PTR)
                CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,NXT,PTR)
                IF (DOLVL.EQ.MDNEST)
     +              CALL ERROR('DO loops too deeply nested')
                DOLVL=DOLVL+1
                DOSTMT(DOLVL)=STPTR
                ENDDO(DOLVL)=PTR
            END IF
        ELSE IF (FGNTYP.EQ.CASE) THEN
            IF (.NOT.XFLCAS(STPTR,FG,MFGNOD,FGSIZE,CASETB,MAXCAS,NCASES,
     +                      NXT,JTABLE,MAXJMP,NJUMPS,IODWRN)) RETURN
        ELSE IF (FGNTYP.EQ.EXIT) THEN
C END only
            CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,0,0)
        ELSE IF (FGNTYP.EQ.JUMP) THEN
C GOTO or RETURN
            IF (NTYPE(STPTR).EQ.83) THEN
C RETURN -- branches to END
                PTR=PREV(DOWN(UP(NXT)))
                IF (DOWN(STPTR).EQ.0) THEN
                    CALL XFADDJ(JTABLE,MAXJMP,NJUMPS,STPTR,PTR)
                ELSE
C Add another node if alternate RETURN though
                    CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,PTR,0)
                END IF
            ELSE
C GOTO -- just branches
                PTR=DOWN(STPTR)
                IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
                IF (ZYJMPA(PTR).EQ.0) THEN
                    CALL XFULER(STPTR,-DOWN(PTR),IODWRN)
                    RETURN
                ELSE IF (ZYJMPA(PTR).EQ.STPTR) THEN
                    CALL XFERRM('Infinite emp'//'ty loop',STPTR,IODWRN)
                    RETURN
                END IF
                CALL XFADDJ(JTABLE,MAXJMP,NJUMPS,STPTR,ZYJMPA(PTR))
            END IF
        ELSE IF (FGNTYP.EQ.JOIN) THEN
C CONTINUE or END IF or ELSE
            IF (DOLVL.GT.0) THEN
                IF (ENDDO(DOLVL).EQ.STPTR) DOLVL=DOLVL-1
                IF (DOLVL.GT.0) THEN
                    IF (ENDDO(DOLVL).EQ.NXT) NXT=DOSTMT(DOLVL)
                END IF
            END IF
            CALL XFADDJ(JTABLE,MAXJMP,NJUMPS,STPTR,NXT)
        END IF
 
        STPTR=NEXTST
        IF (STPTR.NE.0) GOTO 100
 
        IF (DOLVL.NE.0)
     +      CALL ERROR('Internal Error: INCORRECT DO LOOP NESTING')
        IF (NJUMPS.GT.0)
     +      CALL XFIXJP(FG,MFGNOD,FGSIZE,CASETB,MAXCAS,NCASES,JTABLE,
     +                  NJUMPS)
C
C Convert parse tree node numbers into flowgraph node numbers
C
        CALL XFCHNU(FG,FGSIZE,CASETB,MAXCAS,NCASES)
        ZFFLOW=.TRUE.
 
        END
C ----------------------------------------------------------------------
C
C       X F I X I O   -   (Internal) Work out whether an i/o stmt is slc
C                         or case (i.e. if END=/ERR= used).
C
 
        SUBROUTINE XFIXIO(STPTR,FGNTYP)
        INTEGER STPTR,FGNTYP
 
        INTEGER SLC,CASE
        PARAMETER (SLC=1,CASE=4)
 
        INTEGER PTR,PTR2,ENDKD(4),ERRKD(4)
 
        SAVE ENDKD,ERRKD
 
        INTEGER EQUAL
        EXTERNAL EQUAL,ERROR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
        INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
 
        SAVE /XCSTRI/
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C Common block and access functions for YP parse tree
C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C Use "JABC12" to try to avoid conflicts with ordinary variables
        INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
 
        NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
        PREV(JABC12)=(TREE(3,JABC12)/46340)
        UP(JABC12)=(TREE(1,JABC12)/46340)
        DOWN(JABC12)=TREE(2,JABC12)
        NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
        NATTR(JABC12)=TREE(4,JABC12)
 
        DATA ENDKD/69,78,68,129/,ERRKD/69,82,82,129/
 
C IO statements are either SLC (normal case) or CASE (if ERR/END= used)
        PTR=DOWN(STPTR)
 100    IF (NTYPE(PTR).NE.68) THEN
            PTR=NEXT(PTR)
            IF (PTR.NE.0) GOTO 100
            FGNTYP=SLC
        ELSE
            PTR=DOWN(PTR)
 200        IF (NTYPE(PTR).EQ.69) THEN
                PTR2=DOWN(PTR)
                IF (NTYPE(PTR2).NE.118) CALL ERROR(
     +'IMPOSSIBLE ERROR: COULDN''T FIND I/O KEYWORD')
                IF (EQUAL(STRTXT(-DOWN(PTR2)),ENDKD).EQ.-2 .OR.
     +              EQUAL(STRTXT(-DOWN(PTR2)),ERRKD).EQ.-2) THEN
                    FGNTYP=CASE
                ELSE
                    PTR=NEXT(PTR)
                    IF (PTR.NE.0) GOTO 200
                    FGNTYP=SLC
                END IF
            ELSE
                PTR=NEXT(PTR)
                IF (PTR.NE.0) GOTO 200
                FGNTYP=SLC
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       X F C H C L   -   (Internal) Check a CALL stmt for labels (CASE)
C
 
        SUBROUTINE XFCHCL(STPTR,FGNTYP)
        INTEGER STPTR,FGNTYP
 
        INTEGER CASE
        PARAMETER (CASE=4)
 
        INTEGER PTR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C Common block and access functions for YP parse tree
C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C Use "JABC12" to try to avoid conflicts with ordinary variables
        INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
 
        NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
        PREV(JABC12)=(TREE(3,JABC12)/46340)
        UP(JABC12)=(TREE(1,JABC12)/46340)
        DOWN(JABC12)=TREE(2,JABC12)
        NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
        NATTR(JABC12)=TREE(4,JABC12)
 
        PTR=DOWN(STPTR)
 100    IF (NTYPE(PTR).EQ.116) THEN
            FGNTYP=CASE
        ELSE
            PTR=NEXT(PTR)
            IF (PTR.NE.0) GOTO 100
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       X F L C A S   -   (Internal) Flowgraph a "case" statement
C
 
        LOGICAL FUNCTION XFLCAS(STPTR,FG,MFGNOD,FGSIZE,CASETB,MAXCAS,
     +                        NCASES,NEXTST,JTABLE,MAXJMP,NJUMPS,IODWRN)
        INTEGER STPTR,MFGNOD,FGSIZE,MAXCAS,NCASES,NEXTST,MAXJMP,NJUMPS,
     +          IODWRN
        INTEGER FG(8,MFGNOD),CASETB(MAXCAS),JTABLE(2,MAXJMP)
 
        INTEGER NONEXE,SLC,EXIT,BRANCH,CASE,JUMP,JOIN,IO,UNDEF
        PARAMETER (NONEXE=0,SLC=1,EXIT=2,BRANCH=3,CASE=4,JUMP=5,JOIN=6,
     +             IO=7,UNDEF=-1)
 
        INTEGER FGNTYP,CASES,PTR,I,TEXT(134),ENDKD(4),ERRKD(4)
 
        INTEGER ZYJMPA
 
        INTEGER EQUAL
        EXTERNAL EQUAL,ZYGTST,ZYCHNT,ERROR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C Common block and access functions for YP parse tree
C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C Use "JABC12" to try to avoid conflicts with ordinary variables
        INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
 
        NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
        PREV(JABC12)=(TREE(3,JABC12)/46340)
        UP(JABC12)=(TREE(1,JABC12)/46340)
        DOWN(JABC12)=TREE(2,JABC12)
        NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
        NATTR(JABC12)=TREE(4,JABC12)
 
        DATA ENDKD/69,78,68,129/,ERRKD/69,82,82,129/
 
        XFLCAS=.FALSE.
 
C AS-GOTO, CM-GOTO, ARITH-IF (with 3 different labels), or I/O
C (with ERR= or END=).
        FGNTYP=UNDEF
        IF (NTYPE(STPTR).EQ.55) THEN
            CASES=3
        ELSE IF (NTYPE(STPTR).EQ.52 .OR.
     +           NTYPE(STPTR).EQ.82) THEN
            IF (NCASES.EQ.MAXCAS) CALL ERROR('Too many cases')
            NCASES=NCASES+1
            CASETB(NCASES)=NEXTST
            CASES=0
            PTR=DOWN(STPTR)
            IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
            IF (NTYPE(PTR).EQ.54) PTR=DOWN(PTR)
 100        IF (NTYPE(PTR).EQ.116) CASES=CASES+1
            PTR=NEXT(PTR)
            IF (PTR.NE.0) GOTO 100
        ELSE IF (NTYPE(STPTR).EQ.53) THEN
            CALL XFASGO(STPTR,FG,MFGNOD,CASETB,MAXCAS,NCASES,CASES,
     +                  JTABLE,MAXJMP,NJUMPS,IODWRN)
            IF (CASES.EQ.1) XFLCAS=.TRUE.
            IF (CASES.LE.1) RETURN
        ELSE
C Must be IO statement
            PTR=DOWN(STPTR)
 200        IF (NTYPE(PTR).NE.68) THEN
                PTR=NEXT(PTR)
                GOTO 200
            END IF
            PTR=DOWN(PTR)
            CASETB(NCASES+1)=NEXTST
            CASES=1
 300        IF (NTYPE(PTR).EQ.69) THEN
                CALL ZYGTST(-DOWN(DOWN(PTR)),TEXT)
                IF (EQUAL(TEXT,ENDKD).EQ.-2 .OR.
     +              EQUAL(TEXT,ERRKD).EQ.-2) THEN
                    CASES=CASES+1
                    CASETB(NCASES+CASES)=ZYJMPA(NEXT(DOWN(PTR)))
                    IF (CASETB(NCASES+CASES).EQ.0) THEN
                        CALL XFULER(STPTR,-DOWN(NEXT(DOWN(PTR))),IODWRN)
                        RETURN
                    END IF
                END IF
            END IF
            PTR=NEXT(PTR)
            IF (PTR.NE.0) GOTO 300
            FGNTYP=IO
        END IF
        IF (NCASES+CASES.GT.MAXCAS) CALL ERROR('Too many cases')
        IF (FGNTYP.NE.IO .AND. NTYPE(STPTR).NE.53) THEN
            PTR=DOWN(STPTR)
            IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
            IF (NTYPE(STPTR).EQ.55 .OR.
     +          NTYPE(STPTR).EQ.82) THEN
                PTR=NEXT(PTR)
            ELSE
                PTR=DOWN(PTR)
            END IF
            DO 400 I=1,CASES
 350            IF (PTR.LE.0) CALL ERROR('Invalid multiple branch')
                IF (NTYPE(PTR).EQ.116) THEN
                    CASETB(NCASES+I)=ZYJMPA(PTR)
                    IF (CASETB(NCASES+I).EQ.0) THEN
                        CALL XFULER(STPTR,-DOWN(PTR),IODWRN)
                        RETURN
                    END IF
                ELSE
                    PTR=NEXT(PTR)
                    GOTO 350
                END IF
                PTR=NEXT(PTR)
 400        CONTINUE
        END IF
        IF (FGNTYP.EQ.IO) THEN
            CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,-CASES,-NCASES-1)
        ELSE IF (NTYPE(STPTR).EQ.52 .OR.
     +           NTYPE(STPTR).EQ.82) THEN
            CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,-CASES-1,-NCASES)
        ELSE
            CALL XFNODE(FG,MFGNOD,FGSIZE,STPTR,-CASES,-NCASES-1)
            IF (NTYPE(STPTR).EQ.53) CALL ZYCHNT(STPTR,52)
        END IF
        NCASES=NCASES+CASES
        XFLCAS=.TRUE.
 
        END
C ----------------------------------------------------------------------
C
C       X F A S G O   -   Flowgraph an assigned GOTO by converting it to
C                         a computed GOTO
C
 
        SUBROUTINE XFASGO(STPTR,FG,MFGNOD,CASETB,MAXCAS,NCASES,CASES,
     +                    JTABLE,MAXJMP,NJUMPS,IODWRN)
        INTEGER STPTR,MFGNOD,MAXCAS,NCASES,CASES,MAXJMP,NJUMPS,IODWRN
        INTEGER FG(8,MFGNOD),CASETB(MAXCAS),JTABLE(2,MAXJMP)
 
        INTEGER PTR,SYMPTR,I,PTR2,SYMBOL(8),TEXT(134),PTR3
 
        INTEGER ZYASTR,ITOC,ZYCRND
        EXTERNAL ZYASTR,ITOC,ZYCRND,ZYCHNT,ZYADNX,PUTCH,ERROR,ZYGTSY,
     +           ZMESS,ZYCHDN,ZYDELT
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C Common block and access functions for YP parse tree
C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C Use "JABC12" to try to avoid conflicts with ordinary variables
        INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
 
        NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
        PREV(JABC12)=(TREE(3,JABC12)/46340)
        UP(JABC12)=(TREE(1,JABC12)/46340)
        DOWN(JABC12)=TREE(2,JABC12)
        NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
        NATTR(JABC12)=TREE(4,JABC12)
 
        PTR=DOWN(STPTR)
        IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
        IF (NTYPE(PTR).NE.108)
     +      CALL ERROR('IMPOSSIBLE ERROR: INVALID ASSIGNED GOTO')
        SYMPTR=-DOWN(PTR)
        PTR=UP(STPTR)
        IF (NTYPE(PTR).EQ.56) PTR=UP(PTR)
        PTR=DOWN(PTR)
        CASES=0
 
 100    IF (NTYPE(PTR).EQ.56) THEN
            PTR2=NEXT(DOWN(PTR))
        ELSE
            PTR2=PTR
        END IF
        IF (NTYPE(PTR2).EQ.50) THEN
            PTR3=DOWN(PTR2)
            IF (NTYPE(PTR3).EQ.115) PTR3=NEXT(PTR3)
            CALL ZYGTSY(-DOWN(PTR3),SYMBOL)
            IF (SYMBOL(4).EQ.0) THEN
                CALL XFULER(PTR,-DOWN(PTR3),IODWRN)
                CASES=0
                RETURN
            END IF
C Make sure it is not a FORMAT reference!
            IF (NTYPE(SYMBOL(4)).NE.78 .AND.
     +          -DOWN(NEXT(PTR3)).EQ.SYMPTR) THEN
                DO 200 I=1,CASES
                    IF (CASETB(NCASES+I).EQ.-DOWN(PTR3))
     +                  GOTO 300
 200            CONTINUE
C New entry for table...
                IF (NCASES+CASES.EQ.MAXCAS)
     +              CALL ERROR('Too many cases (ASSIGN)')
                CASES=CASES+1
                CASETB(NCASES+I)=-DOWN(PTR3)
C Convert ASSIGN statement into assignment statement
 300            CALL ZYCHNT(PTR2,49)
                CALL ZYCHNT(PTR3,107)
                CALL ZYADNX(PTR3,NEXT(PTR3))
                IF (ITOC(I-1,TEXT,4).GT.2 .AND. IODWRN.GE.0)
     +             CALL ZMESS('MORE THAN 100 ASSIGN STATEMENTS!',IODWRN)
                CALL ZYCHDN(PTR3,-ZYASTR(TEXT))
            END IF
        END IF
        PTR=NEXT(PTR)
        IF (PTR.NE.0) GOTO 100
        IF (CASES.EQ.0) THEN
            CALL XFERRM('No ASSIGNs for assigned GOTO',STPTR,IODWRN)
        ELSE
C The first alternative becomes the "fall-through" case.
            CALL ZYGTSY(CASETB(NCASES+1),SYMBOL)
            IF (CASES.EQ.1) THEN
C If only one alternative, turn into a GOTO...
                CALL XFADDJ(JTABLE,MAXJMP,NJUMPS,STPTR,
     +                      SYMBOL(4))
C Convert now in case program gets output as is (i.e. unstructurable)
                CALL ZYCHNT(STPTR,51)
                PTR2=DOWN(STPTR)
                IF (NTYPE(PTR2).EQ.115) PTR2=NEXT(PTR2)
                CALL ZYCHNT(PTR2,116)
                CALL ZYCHDN(PTR2,-CASETB(NCASES+1))
                IF (NEXT(PTR2).NE.0) CALL ZYDELT(NEXT(PTR2))
                PTR2=STPTR
                IF (NTYPE(UP(PTR2)).EQ.56) PTR2=UP(PTR2)
                IF (IODWRN.GE.0)
     +              CALL XFERRM('Only one target for assigned goto',
     +                          PTR2,IODWRN)
            ELSE
                CASETB(NCASES+1)=SYMBOL(4)
C FLCASE will change the N_ASGOTO to N_CMGOTO later on
C If no label list create one with a (bogus) single element
                PTR=DOWN(STPTR)
                IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
                IF (NEXT(PTR).EQ.0)
     +              CALL ZYADNX(ZYCRND(54,
     +                                 ZYCRND(116,0)),
     +                          PTR)
C Put the label list before the variable for a computed goto
                CALL ZYADNX(PTR,NEXT(PTR))
C Position to the first label in the list
                PTR=DOWN(STPTR)
                IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
                PTR=DOWN(PTR)
                DO 400 I=2,CASES
                    CALL ZYCHDN(PTR,-CASETB(NCASES+I))
                    IF (NEXT(PTR).EQ.0 .AND. I.LT.CASES)
     +                  CALL ZYADNX(ZYCRND(116,0),PTR)
                    CALL ZYGTSY(CASETB(NCASES+I),SYMBOL)
                    CASETB(NCASES+I)=SYMBOL(4)
                    PTR=NEXT(PTR)
 400            CONTINUE
                IF (PTR.NE.0) THEN
C Delete extraneous parts of label list
 500                IF (NEXT(PTR).NE.0) THEN
                        CALL ZYDELT(NEXT(PTR))
                        GOTO 500
                    END IF
                    CALL ZYDELT(PTR)
                END IF
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       X F I X J P   -   Fix jump addresses (use jump table to modify
C                         flowgraph pointers)
C
 
        SUBROUTINE XFIXJP(FG,MFGNOD,FGSIZE,CASETB,MAXCAS,NCASES,JTABLE,
     +                    NJUMPS)
        INTEGER MFGNOD,FGSIZE,MAXCAS,NCASES,NJUMPS
        INTEGER FG(8,MFGNOD),CASETB(MAXCAS),JTABLE(2,NJUMPS)
 
        INTEGER I,J
 
        EXTERNAL ERROR
 
C
C Finished first pass through the tree, now use the jump table to fixup
C control flow by GOTO/CONTINUE/ENDIF/etc
C
        DO 200 I=1,FGSIZE
            DO 100 J=1,NJUMPS
                IF (JTABLE(1,J).EQ.FG(1,I))
     +              CALL ERROR('INTERNAL ERROR: BAD JUMP TABLE')
                IF (JTABLE(1,J).EQ.FG(2,I))
     +              FG(2,I)=JTABLE(2,J)
                IF (JTABLE(1,J).EQ.FG(3,I))
     +              FG(3,I)=JTABLE(2,J)
 100        CONTINUE
 200    CONTINUE
        DO 400 I=1,NCASES
            DO 300 J=1,NJUMPS
                IF (CASETB(I).EQ.JTABLE(1,J)) CASETB(I)=JTABLE(2,J)
 300        CONTINUE
 400    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       X F C H N U   -   (Internal) Change parse tree node numbers to
C                                    flowgraph node numbers
C
C (this is an N**2 algorithm: this can be improved upon)
C
 
        SUBROUTINE XFCHNU(FG,FGSIZE,CASETB,MAXCAS,NCASES)
        INTEGER FGSIZE,MAXCAS,NCASES
        INTEGER FG(8,FGSIZE),CASETB(MAXCAS)
 
        INTEGER I,J
 
        DO 300 I=1,FGSIZE
            DO 100 J=1,FGSIZE
                IF (FG(2,J).EQ.FG(1,I).AND.
     +              FG(1,I).NE.-2)
     +              FG(2,J)=I
                IF (FG(3,J).EQ.FG(1,I))
     +              FG(3,J)=I
 100        CONTINUE
            DO 200 J=1,NCASES
                IF (CASETB(J).EQ.FG(1,I))
     +              CASETB(J)=I
 200        CONTINUE
 300    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       X F A D D J   -   (Internal) Add a jump to the jump table
C
 
        SUBROUTINE XFADDJ(JTABLE,MAXJMP,NJUMPS,JFROM,JTO)
        INTEGER MAXJMP,NJUMPS,JFROM,JTO,JTABLE(2,MAXJMP)
 
        INTEGER I
 
        EXTERNAL ERROR
 
        IF (NJUMPS.EQ.MAXJMP) CALL ERROR(
     +      'XFADDJ: TOO MANY CONTROL TRANSFERS - JUMP TABLE OVERFLOW')
        NJUMPS=NJUMPS+1
        JTABLE(1,NJUMPS)=JFROM
        JTABLE(2,NJUMPS)=JTO
        DO 100 I=1,NJUMPS-1
            IF (JTABLE(1,I).EQ.JTO) JTABLE(2,NJUMPS)=JTABLE(2,I)
 100    CONTINUE
        DO 200 I=1,NJUMPS-1
            IF (JTABLE(2,I).EQ.JFROM) JTABLE(2,I)=JTABLE(2,NJUMPS)
 200    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       Z F S P A N   -   Construct flowgraph's (virtual) spanning tree
C                         and number nodes using a depth-first search.
C
 
        SUBROUTINE ZFSPAN(FG,FGSIZE,STARTN,CASETB,MAXCAS)
        INTEGER FGSIZE,STARTN,MAXCAS
        INTEGER FG(8,FGSIZE),CASETB(MAXCAS)
 
        INTEGER I,PTR,NXT,NUMBER,FROM
 
        EXTERNAL ERROR
 
        DO 100 I=1,FGSIZE
            FG(4,I)=0
 100    CONTINUE
        NUMBER=FGSIZE
        PTR=STARTN
        FROM=0
 200    FG(4,PTR)=-1
C First stack the node we just came from (0 at top)
        FG(8,PTR)=FROM
        FROM=PTR
C Traverse a "true" arc if possible
        IF (FG(2,PTR).GT.0) THEN
            IF (FG(4,FG(2,PTR)).EQ.0) THEN
                PTR=FG(2,PTR)
                GOTO 200
            END IF
        END IF
C Traverse a "false" arc if possible
        IF (FG(3,PTR).GT.0) THEN
            IF (FG(4,FG(3,PTR)).EQ.0) THEN
                PTR=FG(3,PTR)
                GOTO 200
            END IF
        END IF
C Traverse an element in a multiple branch if possible
        IF (FG(2,PTR).LT.0) THEN
            NXT=-FG(2,PTR)
            I=-FG(3,PTR)
 300        IF (FG(4,CASETB(I)).EQ.0) THEN
                PTR=CASETB(I)
                GOTO 200
            END IF
            I=I+1
            NXT=NXT-1
            IF (NXT.GT.0) GOTO 300
        END IF
C All descendents visited: number this node properly and return
C to its parent.
        FG(4,PTR)=NUMBER
        NUMBER=NUMBER-1
        FROM=FG(8,PTR)
        IF (FROM.NE.0) THEN
            FG(8,PTR)=0
            PTR=FROM
            FROM=FG(8,PTR)
            GOTO 200
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       Z F L O O P   -   Add repeat nodes to the flowgraph
C
 
        SUBROUTINE ZFLOOP(FG,MFGNOD,STARTN,FGSIZE,CASETB,MAXCAS,NCASES,
     +                    IODWRN)
        INTEGER MFGNOD,STARTN,FGSIZE,MAXCAS,NCASES,IODWRN
        INTEGER FG(8,MFGNOD),CASETB(MAXCAS)
 
        INTEGER I,J,N
 
        DO 100 I=1,FGSIZE
            FG(5,I)=0
 100    CONTINUE
        DO 300 I=1,FGSIZE
            IF (FG(2,I).GE.0) THEN
C Check "true" outarc first
                CALL XFCFBA(FG,MFGNOD,FGSIZE,FG(2,I),
     +                    FG(4,I),IODWRN)
C Check "false" outarc next
                CALL XFCFBA(FG,MFGNOD,FGSIZE,FG(3,I),
     +                    FG(4,I),IODWRN)
            ELSE
C Check multiple branch outarcs
                J=-FG(3,I)
                N=-FG(2,I)
 200            CALL XFCFBA(FG,MFGNOD,FGSIZE,CASETB(J),FG(4,I),
     +                      IODWRN)
                J=J+1
                N=N-1
                IF (N.GT.0) GOTO 200
            END IF
 300    CONTINUE
C If repeat node inserted before start node, make it the start node.
        IF (FG(5,STARTN).NE.0) STARTN=FG(5,STARTN)
C Make forward arcs to the previously repeating nodes point to the
C new repeat nodes
        DO 400 I=1,FGSIZE
            IF (FG(1,I).NE.(-1)) THEN
                IF (FG(2,I).GT.0) THEN
                    IF (FG(5,FG(2,I)).NE.0)
     +                  FG(2,I)=FG(5,FG(2,I))
                END IF
                IF (FG(3,I).GT.0) THEN
                    IF (FG(5,FG(3,I)).NE.0)
     +                  FG(3,I)=FG(5,FG(3,I))
                END IF
            END IF
 400    CONTINUE
        DO 500 I=1,NCASES
            IF (FG(5,CASETB(I)).NE.0)
     +          CASETB(I)=FG(5,CASETB(I))
 500    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       X F C F B A   -   (Internal) Check For Back Arc
C                                    (and add repeat node if found)
C
 
        SUBROUTINE XFCFBA(FG,MFGNOD,FGSIZE,NODE,NUMBER,IODWRN)
        INTEGER MFGNOD,FGSIZE,NODE,NUMBER,IODWRN
        INTEGER FG(8,MFGNOD)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C Common block and access functions for YP parse tree
C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C Use "JABC12" to try to avoid conflicts with ordinary variables
        INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
 
        NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
        PREV(JABC12)=(TREE(3,JABC12)/46340)
        UP(JABC12)=(TREE(1,JABC12)/46340)
        DOWN(JABC12)=TREE(2,JABC12)
        NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
        NATTR(JABC12)=TREE(4,JABC12)
 
        IF (NODE.GT.0 .AND. NUMBER.GT.0) THEN
            IF (FG(4,NODE).LE.NUMBER) THEN
                IF (FG(5,NODE).NE.0) THEN
                    NODE=FG(5,NODE)
                ELSE
                    CALL XFNODE(FG,MFGNOD,FGSIZE,-1,NODE,0)
                    FG(4,FGSIZE)=FG(4,NODE)
                    FG(5,NODE)=FGSIZE
                    IF (FG(4,FGSIZE).EQ.NUMBER)
     +                  CALL XFERRM('Null loop detected',
     +                              FG(1,NODE),IODWRN)
                    NODE=FGSIZE
                END IF
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       X F N O D E   -   (Internal) Add a flowgraph node
C
 
        SUBROUTINE XFNODE(FG,MFGNOD,FGSIZE,PTNODE,TRUE,FALSE)
        INTEGER MFGNOD,FGSIZE,PTNODE,TRUE,FALSE
        INTEGER FG(8,MFGNOD)
 
        EXTERNAL ERROR
 
        IF (FGSIZE.EQ.MFGNOD) CALL ERROR('Program unit too complicated')
        FGSIZE=FGSIZE+1
        FG(1,FGSIZE)=PTNODE
        FG(2,FGSIZE)=TRUE
        FG(3,FGSIZE)=FALSE
        FG(4,FGSIZE)=0
        FG(5,FGSIZE)=0
        FG(6,FGSIZE)=0
        FG(7,FGSIZE)=0
        FG(8,FGSIZE)=0
 
        END
C ----------------------------------------------------------------------
C
C       Z F S H E D   -   Traverse a basic flowgraph, annotating it with
C                         HEAD pointers.
C
 
        LOGICAL FUNCTION ZFSHED(FG,FGSIZE,STARTN,CASETB,MAXCAS,IODWRN)
        INTEGER FGSIZE,STARTN,MAXCAS,IODWRN
        INTEGER FG(8,FGSIZE),CASETB(MAXCAS)
 
        INTEGER PTRSTK,BRNSTK,VISITD
        PARAMETER (PTRSTK=6,BRNSTK=7,VISITD=8)
 
        INTEGER I,BRNUM,PTR,NXT,J,FROM,FROMB
 
        LOGICAL XSHEAD
 
        EXTERNAL ERROR
 
        ZFSHED=.FALSE.
 
C
C ... Set FG(fg_head,*) to HEAD()
C ... FG(fg_dom,*) & FG(fg_inarcs,*) used as a stack
C ... FG(fg_follow,*) used as "visited" pointer
C
        DO 100 I=1,FGSIZE
            FG(5,I)=0
C FG(fg_dom,I) already set to zero on entry
C FG(fg_inarcs,I) already set to zero on entry
C FG(fg_follow,I) already set to zero on entry
 100    CONTINUE
 
        BRNUM=0
        PTR=STARTN
        FROM=0
        FROMB=0
 200    CONTINUE
        FG(PTRSTK,PTR)=FROM
        FG(BRNSTK,PTR)=FROMB
C Mark this node as visited
        FG(VISITD,PTR)=1
        FROM=PTR
        FROMB=BRNUM
C Traverse a forward "true" arc if we have not yet already done so
        IF (FG(2,PTR).GT.0 .AND. BRNUM.EQ.0) THEN
            IF (FG(4,FG(2,PTR)).LT.FG(4,PTR) .OR.
     +          FG(4,FG(2,PTR)).EQ.FG(4,PTR) .AND.
     +          FG(1,FG(2,PTR)).EQ.-1) THEN
C arc is a backward (loop) arc -- set head refs
                IF (.NOT.XSHEAD(FG,FGSIZE,PTR,FG(2,PTR),IODWRN))
     +                  RETURN
            ELSE IF (FG(VISITD,FG(2,PTR)).EQ.0) THEN
                PTR=FG(2,PTR)
                GOTO 200
            ELSE
                IF (FG(5,FG(2,PTR)).NE.0) THEN
                    IF (.NOT.XSHEAD(FG,FGSIZE,PTR,
     +                              FG(5,FG(2,PTR)),IODWRN))
     +                  RETURN
                END IF
            END IF
            BRNUM=1
            FROMB=BRNUM
        END IF
C Traverse a forward "false" arc if we haven't yet
        IF (FG(3,PTR).GT.0 .AND. BRNUM.EQ.1) THEN
            IF (FG(4,FG(3,PTR)).LT.FG(4,PTR) .OR.
     +          FG(4,FG(3,PTR)).EQ.FG(4,PTR).AND.
     +          FG(1,FG(3,PTR)).EQ.-1) THEN
C arc is a backward (loop) arc -- set head refs
                IF (.NOT.XSHEAD(FG,FGSIZE,PTR,FG(3,PTR),IODWRN))
     +              RETURN
            ELSE IF (FG(VISITD,FG(3,PTR)).EQ.0) THEN
                PTR=FG(3,PTR)
                BRNUM=0
                GOTO 200
            ELSE
                IF (FG(5,FG(3,PTR)).NE.0) THEN
                    IF (.NOT.XSHEAD(FG,FGSIZE,PTR,
     +                              FG(5,FG(3,PTR)),IODWRN)
     +                 )RETURN
                END IF
            END IF
            BRNUM=2
        END IF
C Traverse an element in a multiple branch if a forward arc ...
        IF (FG(2,PTR).LT.0) THEN
            NXT=-FG(2,PTR)
            J=-FG(3,PTR)
2600        IF (FG(4,CASETB(J)).GT.FG(4,PTR)) THEN
                IF (BRNUM.LE.0 .AND.
     +              FG(VISITD,CASETB(J)).EQ.0) THEN
                    FROMB=FROMB-BRNUM
                    PTR=CASETB(J)
                    BRNUM=0
                    GOTO 200
                ELSE IF (BRNUM.LE.0) THEN
                    IF (FG(5,CASETB(J)).NE.0) THEN
                        IF (.NOT.XSHEAD(FG,FGSIZE,PTR,
     +                                  FG(5,CASETB(J)),IODWRN))
     +                      RETURN
                    END IF
                END IF
            ELSE IF (FG(4,CASETB(J)).EQ.FG(4,PTR) .AND.
     +               FG(1,CASETB(J)).NE.-1) THEN
                CALL ERROR('IMPOSSIBLE LOOP SITUATION')
            ELSE
C arc is a backward (loop) arc -- set head refs
                IF (.NOT.XSHEAD(FG,FGSIZE,PTR,CASETB(J),IODWRN))
     +              RETURN
            END IF
            J=J+1
            NXT=NXT-1
            BRNUM=BRNUM-1
            IF (NXT.GT.0) GOTO 2600
        END IF
C No more forward arcs ...
        IF (FG(PTRSTK,PTR).NE.0) THEN
C FROM=PTR at this point
            BRNUM=FG(BRNSTK,PTR)+1
            PTR=FG(PTRSTK,PTR)
            FG(PTRSTK,FROM)=0
            FG(BRNSTK,FROM)=0
            FROM=FG(PTRSTK,PTR)
            FROMB=FG(BRNSTK,PTR)
            GOTO 200
        END IF
 
        ZFSHED=.TRUE.
 
        END
C ----------------------------------------------------------------------
C
C       X S H E A D   -   (Internal) Set HEAD fields in flowgraph nodes
C
 
        LOGICAL FUNCTION XSHEAD(FG,FGSIZE,PTR,HEAD,IODWRN)
        INTEGER FGSIZE,PTR,HEAD,IODWRN
        INTEGER FG(8,FGSIZE)
 
        INTEGER PTRSTK
        PARAMETER (PTRSTK=6)
 
        INTEGER I
 
C First check for irreducibility
        I=PTR
 100    IF (I.NE.HEAD .AND. I.NE.0) THEN
            I=FG(PTRSTK,I)
            GOTO 100
        END IF
        IF (I.NE.HEAD) THEN
C Yes - error message
            XSHEAD=.FALSE.
            IF (FG(1,PTR).GT.0)
     +          CALL XFERRM('Multiple-entry loop discovered',
     +                      FG(1,PTR),IODWRN)
 
        ELSE
C Normal processing
 200        XSHEAD=.TRUE.
            I=PTR
 300        IF (I.NE.HEAD) THEN
                IF (FG(5,I).EQ.0) THEN
                    FG(5,I)=HEAD
                ELSE IF (FG(4,FG(5,I)).LT.
     +                   FG(4,HEAD)) THEN
                    FG(5,I)=HEAD
                END IF
                I=FG(PTRSTK,I)
                GOTO 300
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       Z F S D O M   -   Set the dominator pointers
C
 
        SUBROUTINE ZFSDOM(FG,FGSIZE,CASETB,MAXCAS,STARTN)
        INTEGER FGSIZE,MAXCAS,STARTN
        INTEGER FG(8,FGSIZE),CASETB(MAXCAS)
 
        INTEGER I,J
 
C Duplicate the count (in fg_follow)
 
        DO 100 I=1,FGSIZE
            FG(8,I)=FG(7,I)
 100    CONTINUE
 
C Begin at the beginning
 
        I=STARTN
 
 200    CONTINUE
C Here to visit a node - number I
        IF (FG(2,I).GT.0) THEN
C the true outarc
            CALL XDOMIN(FG,FGSIZE,FG(2,I),I)
C the false outarc, if any
            IF (FG(3,I).GT.0)
     +          CALL XDOMIN(FG,FGSIZE,FG(3,I),I)
        ELSE IF (FG(2,I).LT.0) THEN
C Case statement
            DO 300 J=-FG(3,I),-FG(3,I)-FG(2,I)-1
                CALL XDOMIN(FG,FGSIZE,CASETB(J),I)
 300        CONTINUE
        END IF
C Make sure we don't ever visit this one again
        FG(8,I)=-1
 
C Find a node we can visit next
        DO 400 I=1,FGSIZE
            IF (FG(8,I).EQ.0 .AND.
     +          FG(4,I).NE.0) GOTO 200
 400    CONTINUE
 
C If we are here we must have finished; better clear up the follow fld
 
        DO 500 I=1,FGSIZE
            IF (FG(8,I).NE.-1 .AND. FG(4,I).NE.0)
     +          CALL ERROR('INTERNAL ERROR: SETDOM FAILED')
            FG(8,I)=0
 500    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       Z F I C N T   -   Count number of forward inarcs entering each
C                         node.
C
 
        SUBROUTINE ZFICNT(FG,FGSIZE,CASETB,MAXCAS)
        INTEGER FGSIZE,MAXCAS
        INTEGER FG(8,FGSIZE),CASETB(MAXCAS)
 
        INTEGER I,J
 
        DO 200 I=1,FGSIZE
            IF (FG(2,I).GT.0 .AND. FG(4,I).GT.0) THEN
                IF (FG(4,I).LT.FG(4,FG(2,I)) .OR.
     +              FG(4,I).EQ.FG(4,FG(2,I)) .AND.
     +              FG(1,I).EQ.-1)
     +              FG(7,FG(2,I))=
     +                  FG(7,FG(2,I))+1
                IF (FG(3,I).GT.0) THEN
                IF (FG(4,I).LT.FG(4,FG(3,I)) .OR.
     +              FG(4,I).EQ.FG(4,FG(3,I)).AND.
     +              FG(1,I).EQ.-1)
     +              FG(7,FG(3,I))=
     +                  FG(7,FG(3,I))+1
                END IF
            ELSE IF (FG(2,I).LT.0 .AND. FG(4,I).GT.0) THEN
                DO 100 J=-FG(3,I),-FG(3,I)-FG(2,I)-1
                    IF (FG(4,I).LT.FG(4,CASETB(J)) .OR.
     +                  FG(4,I).EQ.FG(4,CASETB(J)) .AND.
     +                  FG(1,I).EQ.-1)
     +                  FG(7,CASETB(J))=
     +                      FG(7,CASETB(J))+1
 100            CONTINUE
            END IF
 200    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       X D O M I N   -   Say a node may dominate another (or may not)
C
 
        SUBROUTINE XDOMIN(FG,FGSIZE,NODE,DOM)
        INTEGER FGSIZE,NODE,DOM
        INTEGER FG(8,FGSIZE)
 
        INTEGER I,J
 
        IF (FG(4,NODE).GT.FG(4,DOM) .OR.
     +      FG(4,NODE).EQ.FG(4,DOM) .AND.
     +      FG(1,DOM).EQ.-1) THEN
            IF (FG(6,NODE).EQ.0) THEN
                FG(6,NODE)=DOM
            ELSE IF (FG(6,NODE).NE.DOM) THEN
                I=FG(6,NODE)
 100            J=DOM
 200            IF (I.NE.J) THEN
                    J=FG(6,J)
                    IF (J.NE.0) GOTO 200
                    I=FG(6,I)
                    IF (I.NE.0) GOTO 100
                    CALL ERROR('IMPOSSIBLE ERROR: NO DOMINATOR FOUND')
                ELSE
                    FG(6,NODE)=J
                END IF
            END IF
            FG(8,NODE)=FG(8,NODE)-1
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       Z F F O L L   -   Make FOLLOW sets
C
 
        SUBROUTINE ZFFOLL(FG,FGSIZE,CASETB,MAXCAS)
        INTEGER FGSIZE,MAXCAS
        INTEGER FG(8,FGSIZE),CASETB(MAXCAS)
 
        INTEGER I,J,NXT,NJUMPS,TO
 
        EXTERNAL ERROR
 
        DO 3000 I=1,FGSIZE
C Calculate FOLLOW set for node I
            IF (FG(1,I).EQ.(-1)) THEN
C REPEAT FOLLOW set:
                DO 2800 J=1,FGSIZE
C require HEAD(I)=HEAD(J) (and DOM(J) not to be undefined)
                    IF (FG(5,I).EQ.FG(5,J) .AND.
     +                  FG(6,J).NE.0) THEN
C and DOM(J) in loop tail of I,
C i.e. HEAD(DOM(J))=I or HEAD(HEAD(DOM(J)))=I or ...
                        NXT=FG(6,J)
2700                    IF (FG(5,NXT).NE.I) THEN
                            NXT=FG(5,NXT)
                            IF (NXT.NE.0) GOTO 2700
                        ELSE IF (FG(8,J).NE.0) THEN
                            CALL ERROR(
     +'IMPOSSIBLE ERROR: FOLLOW SETS NOT DISJOINT')
                        ELSE
                            FG(8,J)=I
                        END IF
                    END IF
2800            CONTINUE
            ELSE
                DO 2900 J=1,FGSIZE
C SLC FOLLOW set:
C J in FOLLOW(I) iff HEAD(J)=HEAD(I) and DOM(J)=I
C IF FOLLOW set:
C same except also require number of forward inarcs >= 2
C CASE FOLLOW set: (similar to IF)
C ditto only number of forward inarcs must be > number of jumps
C to that particular case
                    IF (FG(5,J).EQ.FG(5,I) .AND.
     +                  I.EQ.FG(6,J)) THEN
                        IF (FG(2,I).LT.0) THEN
                            NJUMPS=0
                            NXT=-FG(3,I)
                            TO=-FG(3,I)-FG(2,I)-1
2850                        IF (CASETB(NXT).EQ.J) NJUMPS=NJUMPS+1
                            NXT=NXT+1
                            IF (NXT.LE.TO) GOTO 2850
                            IF (FG(7,J).GT.NJUMPS) THEN
                                IF (FG(8,J).NE.0) CALL ERROR(
     +'IMPOSSIBLE ERROR: FOLLOW SETS NOT DISJOINT (CASE STMT)')
                                FG(8,J)=I
                            END IF
                        ELSE IF (FG(3,I).EQ.0 .OR.
     +                           FG(7,J).GE.2) THEN
                            IF (FG(8,J).NE.0) CALL ERROR(
     +'IMPOSSIBLE ERROR: FOLLOW SETS NOT DISJOINT')
                            FG(8,J)=I
                        END IF
                    END IF
2900            CONTINUE
            END IF
3000    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       X F U L E R   -   report an Undefined Label ERror
C
 
        SUBROUTINE XFULER(STPTR,LBSYMP,IODWRN)
        INTEGER STPTR,LBSYMP,IODWRN
 
        INTEGER SYMBOL(8),TEXT(1322)
 
        INTEGER ZYGPUS,ZYGTXF
        EXTERNAL ZYGPUS,ZYGTXF,ZCHOUT,ZYGTSY,ZYGTST,PUTLIN,PUTCH
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C Common block and access functions for YP parse tree
C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C Use "JABC12" to try to avoid conflicts with ordinary variables
        INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
 
        NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
        PREV(JABC12)=(TREE(3,JABC12)/46340)
        UP(JABC12)=(TREE(1,JABC12)/46340)
        DOWN(JABC12)=TREE(2,JABC12)
        NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
        NATTR(JABC12)=TREE(4,JABC12)
 
        CALL ZCHOUT('Undefined label ',IODWRN)
        CALL ZYGTSY(LBSYMP,SYMBOL)
        CALL ZYGTST(SYMBOL(2),TEXT)
        CALL PUTLIN(TEXT,IODWRN)
        CALL ZCHOUT(' at statement ',IODWRN)
        CALL ZPTINT(NATTR(STPTR)-NATTR(DOWN(UP(STPTR)))+1,1,IODWRN)
        CALL ZCHOUT(' in ',IODWRN)
        CALL ZYGTSY(ZYGPUS(SYMBOL(3)),SYMBOL)
        CALL ZYGTST(SYMBOL(2),TEXT)
        CALL PUTLIN(TEXT,IODWRN)
        CALL PUTCH(10,IODWRN)
 
        END
C ----------------------------------------------------------------------
C
C       X F E R R M   -   Error Message
C
 
        SUBROUTINE XFERRM(STRING,STPTR,IODWRN)
        CHARACTER*(*) STRING
        INTEGER STPTR,IODWRN
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
        INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
 
        SAVE /XCSTRI/
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
 
        INTEGER NODE
 
        INTEGER ZYPUSY
        EXTERNAL ZYPUSY
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C Common block and access functions for YP parse tree
C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C Use "JABC12" to try to avoid conflicts with ordinary variables
        INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
 
        NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
        PREV(JABC12)=(TREE(3,JABC12)/46340)
        UP(JABC12)=(TREE(1,JABC12)/46340)
        DOWN(JABC12)=TREE(2,JABC12)
        NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
        NATTR(JABC12)=TREE(4,JABC12)
 
        NODE=STPTR
        IF (NTYPE(UP(NODE)).EQ.56) NODE=UP(NODE)
        CALL ZCHOUT(STRING,IODWRN)
        CALL ZCHOUT(' at statement ',IODWRN)
        CALL ZPTINT(NATTR(NODE)-NATTR(DOWN(UP(NODE)))+1,1,IODWRN)
        CALL ZCHOUT(' in ',IODWRN)
        CALL PUTLIN(STRTXT(SYMBOL(2,ZYPUSY(UP(NODE)))),IODWRN)
        CALL PUTCH(10,IODWRN)
 
        END
